perm filename EARLY.F4[XX,LCS]1 blob
sn#199910 filedate 1976-02-04 generic text, type T, neo UTF8
00100 C ********** EARLY MUSIC NOTATION PACKAGE ************
00200 SUBROUTINE EARLY
00300 IMPLICIT INTEGER(A-Q,S-Z)
00400 REAL POS
00500 COMMON /STF/RSTFAC(-3/4),RSTJ2
00600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00700 COMMON/PLTR/PLT,RHT,DIS /POSI/STFF(-3/4),JJ2,POS
00800 COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RB,RZ,RJY,
00900 1 QQ,RJW,ZZ,JX,RG,KL,RJAC,K,L,RQ,RXO,J5X,RNO,JJJ,
01000 1 PUNCT,RDIS,RJ
01100 EQUIVALENCE (R4,RJQ(2)),(J5,JQ(3)),(R6,RJQ(4)),(NJR,RJQ(8)),
01200 1 (J6,JQ(4)),(R8,RJQ(6)),(R7,RJQ(5)),(R9,RJQ(7)),(J9,JQ(7))
01300 1,(J4,JQ(2)),(R3,RJQ(1)),(J10,JQ(8)),(R11,RJQ(9)),(J8,JQ(6))
01400 1,(J7,JQ(5)),(RX3,RJQ(20)),(R5,RJQ(3)),(RH,RJQ(19)),(RXX,RJQ(18))
01500 DATA RBIG/1.5/
01600
01700 IF(JA.EQ.2)R9=R7
01800 KL=IABS(J6)
01900 IF(KL.GT.5)GO TO 10
02000 IF(R9.NE.0)GO TO 2
02100 10 IF(JA.EQ.1)J5=J6
02200 IF(KL.GE.30)GO TO 30
02300 C JUMP FOR MENSURATION SIGNS.
02400 C PUT NUM. IN P6 IF P9 NOT USED. 20=MAXIMA, 21=LONGA, 22=BREVIS, ETC.
02500 IF(R8.EQ.0)R8=-2
02600 C SET 'COLORATION' IN P8 IF NOT SET BY RHYTH.(P9) -1=BLACK, 0=WHITE HERE.
02700 GO TO 3
02800 2 RA=AMOD(R9,.25)
02900 C RA=0=WHITE, ≠0='COLORATION'
03000 IF(RA.NE.0)R9=R9*1.5
03100 C TO GET THE RIGHT SHAPE
03200 J5=19.5+ALOG(16./R9)/.693147181
03300 C I.E. /ALOG(2.) FINDS SEQ. NUM IN DRAW FILE 'EARLY'. 20=MAXIMA, ETC.
03400 R8=-1
03500 C FILL IT ALWAYS (BLACK NOTE)
03600 IF(RA.EQ.0)R8=-2
03700 C ALWAYS WHITE
03800 3 IF(JA.EQ.2)GO TO 20
03900 RH=R5
04000 JA=3
04100 K=J4
04200 RXX=POS-18.*RSTJ2
04300 IF(J5.LT.20)GO TO 6
04400 C GO MAKE 'LIGATURES' P6=11=1 UP, =-11=1 DOWN, 12=2 UP, ETC.
04500 R6=RBIG
04600 NJR='CLEF2'
04700 C ↑↑↑ EQUIV. TO R10
04800 R7=RBIG
04900 IF(R5)R6=-R6
05000 C IF P5 IS NEG THEN ITEM MOVES TO LEFT EXACTLY ITS SPACE.
05100 5 J9=0
05200 C NO ROTATION PLEASE.
05300 CC IF(R5.LT.20.)GO TO 7
05400 C TURN OVER THE NOTE
05500 CC R4=R4-5.8
05600 CC R7=-R6
05650 7 RSS=RG
05700 CALL CLEFS
05800 IF(J7.GE.0)GO TO 1
05900 C IF P7 IS NEG THERE WILL BE A STEM ON LFT SIDE =ABS(R7), P5 HAS UP-DN.
06000 RG=R4
06100 R5=-J7*RST7
06200 GO TO 14
06300 6 RG=R4
06400 C THIS WILL BE FOR LIGATURE STEMS (P5=10=UP, =20=DOWN)
06500 IF(KL.GT.10)GO TO 11
06600 R6=-R6*10.
06700 GO TO 12
06800 11 R6=KL-10
06900 IF(J6)R6=-R6
07000 12 RA=R3
07100 IF(J8)GO TO 9
07200 R4=R4-.45
07300 J5=50
07400 C P8<0=BLACK LIG. ≥0=WHITE LIG.
07500 J10=1
07600 R9=1.7
07700 R8=3.64
07800 R11=R6
07900 R3=R3+13.85*RSTJ2
08000 GO TO 8
08100 9 R4=R4-.9
08200 R5=R4+R6/RSTJ2
08300 CC R9=200
08400 J7=1
08500 R8=4.6
08600 R6=RX3+R8
08700 J10=14.*RSTJ2
08800 C MAKES SLOPED DASH, 14XTHICK
08900 8 CALL ITMSUB
09000 IF(RH.EQ.0)GO TO 13
09100 R5=5*RST7
09200 14 RG=RG*RST7+RXX
09300 IF(RH.GE.20)R5=-R5
09400 C NOW STEM IS DOWN. (-R5)
09500 CALL LINX(R3,RG,R3,RG+R5)
09600 13 R4=RG
09700 J5=20
09800 R3=RA
09900
10000 1 IF(K.LT.502)GO TO 4
10100 IF(K.LT.513)RETURN
10200 C WILL NOW DO 1 LEDG. LINE ABOVE OR BELOW.
10300 4 R4=RST7
10400 IF(K.GT.502)R4=13.*RST7
10500 R4=R4+RXX
10600 R5=20.
10700 IF(J5.EQ.20)R5=34.
10800 CALL LINX(R3-RST7,R4,R3+R5*RSTJ2,R4)
10900
11000 RETURN
11100
11200 20 IF(R9.NE.0)J5=R5+23.
11300 RG=POS
11400 C SAVE IT FOR SEMIMINIM REST HORIZANTAL
11500 C RESTS ARE SET BY RHYTHM(R9,7) OR IN J5 (20-25)
11600 R5=(J5-20)*2+3
11700 RA=R4
11800 IF(R5.GT.8.)R5=8.
11900 R5=R4+R5
12000 C RESTS (500+ IN P4) CAN BE MOVED UP OR DOWN
12100 R4=9
12200 IF(J5.GT.23)R4=7.
12300 R4=R4+RA
12400 J10=2
12500 J7=0
12600 R6=RX3
12700 C ALL THIS MAKES VERT. LINE.
12800 CALL ITMSUB
12900 IF(J5.LT.25)RETURN
13000 C NEXT IS FOR SEMIMINIM REST (1/16)
13100 R6=RX3+1.3
13200 R4=8+RA
13300 R5=R4
13400 POS=RG
13500 CALL ITMSUB
13600 RETURN
13700
13800 C MENSURATION SIGNS. USES P6 AS A NOTE. =30=C; 31=C.; 32=C/; 33=O; 34=O/
13900 30 JA=12
13910 R4=R4+6
13920 CALL CENTX
13930 C P4=500 PUTS IT AT POS 6.
14000 R5=1
14100 J8=1
14200 IF(J5.GT.32)GO TO 31
14300 C NEXT ARE C'S
14400 J6=125
14500 J7=45
14600 GO TO 32
14700 31 J6=0
14800 J7=0
14900 32 CALL SLUR
15000 IF(J5.NE.31)GO TO 33
15100 C NEXT IS C.
15110 J5=0
15200 J6=0
15250 J7=0
15300 R5=.1
15400 GO TO 31
15500 33 IF(J5.LT.32)RETURN
15600 IF(J5.EQ.33)RETURN
15800 R5=R4+1
15810 R4=R4-1
15900 R3=R3-11.*RSTJ2
16000 J7=0
16100 R6=RX3+2*RSTJ2
16200 CALL ITMSUB
16300 END